home *** CD-ROM | disk | FTP | other *** search
/ Mac Easy 2010 May / Mac Life Ubuntu.iso / casper / filesystem.squashfs / usr / share / perl5 / LWP / Protocol / gopher.pm < prev    next >
Encoding:
Perl POD Document  |  2008-04-11  |  5.6 KB  |  215 lines
  1. package LWP::Protocol::gopher;
  2.  
  3. # Implementation of the gopher protocol (RFC 1436)
  4. #
  5. # This code is based on 'wwwgopher.pl,v 0.10 1994/10/17 18:12:34 shelden'
  6. # which in turn is a vastly modified version of Oscar's http'get()
  7. # dated 28/3/94 in <ftp://cui.unige.ch/PUBLIC/oscar/scripts/http.pl>
  8. # including contributions from Marc van Heyningen and Martijn Koster.
  9.  
  10. use strict;
  11. use vars qw(@ISA);
  12.  
  13. require HTTP::Response;
  14. require HTTP::Status;
  15. require IO::Socket;
  16. require IO::Select;
  17.  
  18. require LWP::Protocol;
  19. @ISA = qw(LWP::Protocol);
  20.  
  21.  
  22. my %gopher2mimetype = (
  23.     '0' => 'text/plain',                # 0 file
  24.     '1' => 'text/html',                 # 1 menu
  25.                     # 2 CSO phone-book server
  26.                     # 3 Error
  27.     '4' => 'application/mac-binhex40',  # 4 BinHexed Macintosh file
  28.     '5' => 'application/zip',           # 5 DOS binary archive of some sort
  29.     '6' => 'application/octet-stream',  # 6 UNIX uuencoded file.
  30.     '7' => 'text/html',                 # 7 Index-Search server
  31.                     # 8 telnet session
  32.     '9' => 'application/octet-stream',  # 9 binary file
  33.     'h' => 'text/html',                 # html
  34.     'g' => 'image/gif',                 # gif
  35.     'I' => 'image/*',                   # some kind of image
  36. );
  37.  
  38. my %gopher2encoding = (
  39.     '6' => 'x_uuencode',                # 6 UNIX uuencoded file.
  40. );
  41.  
  42. sub request
  43. {
  44.     my($self, $request, $proxy, $arg, $size, $timeout) = @_;
  45.  
  46.     LWP::Debug::trace('()');
  47.  
  48.     $size = 4096 unless $size;
  49.  
  50.     # check proxy
  51.     if (defined $proxy) {
  52.     return HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST,
  53.                    'You can not proxy through the gopher');
  54.     }
  55.  
  56.     my $url = $request->url;
  57.     die "bad scheme" if $url->scheme ne 'gopher';
  58.  
  59.  
  60.     my $method = $request->method;
  61.     unless ($method eq 'GET' || $method eq 'HEAD') {
  62.     return HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST,
  63.                    'Library does not allow method ' .
  64.                    "$method for 'gopher:' URLs");
  65.     }
  66.  
  67.     my $gophertype = $url->gopher_type;
  68.     unless (exists $gopher2mimetype{$gophertype}) {
  69.     return HTTP::Response->new(&HTTP::Status::RC_NOT_IMPLEMENTED,
  70.                    'Library does not support gophertype ' .
  71.                    $gophertype);
  72.     }
  73.  
  74.     my $response = HTTP::Response->new(&HTTP::Status::RC_OK, "OK");
  75.     $response->header('Content-type' => $gopher2mimetype{$gophertype}
  76.                     || 'text/plain');
  77.     $response->header('Content-Encoding' => $gopher2encoding{$gophertype})
  78.     if exists $gopher2encoding{$gophertype};
  79.  
  80.     if ($method eq 'HEAD') {
  81.     # XXX: don't even try it so we set this header
  82.     $response->header('Client-Warning' => 'Client answer only');
  83.     return $response;
  84.     }
  85.     
  86.     if ($gophertype eq '7' && ! $url->search) {
  87.       # the url is the prompt for a gopher search; supply boiler-plate
  88.       return $self->collect_once($arg, $response, <<"EOT");
  89. <HEAD>
  90. <TITLE>Gopher Index</TITLE>
  91. <ISINDEX>
  92. </HEAD>
  93. <BODY>
  94. <H1>$url<BR>Gopher Search</H1>
  95. This is a searchable Gopher index.
  96. Use the search function of your browser to enter search terms.
  97. </BODY>
  98. EOT
  99.     }
  100.  
  101.     my $host = $url->host;
  102.     my $port = $url->port;
  103.  
  104.     my $requestLine = "";
  105.  
  106.     my $selector = $url->selector;
  107.     if (defined $selector) {
  108.     $requestLine .= $selector;
  109.     my $search = $url->search;
  110.     if (defined $search) {
  111.         $requestLine .= "\t$search";
  112.         my $string = $url->string;
  113.         if (defined $string) {
  114.         $requestLine .= "\t$string";
  115.         }
  116.     }
  117.     }
  118.     $requestLine .= "\015\012";
  119.  
  120.     # potential request headers are just ignored
  121.  
  122.     # Ok, lets make the request
  123.     my $socket = IO::Socket::INET->new(PeerAddr => $host,
  124.                        PeerPort => $port,
  125.                        Proto    => 'tcp',
  126.                        Timeout  => $timeout);
  127.     die "Can't connect to $host:$port" unless $socket;
  128.     my $sel = IO::Select->new($socket);
  129.  
  130.     {
  131.     die "write timeout" if $timeout && !$sel->can_write($timeout);
  132.     my $n = syswrite($socket, $requestLine, length($requestLine));
  133.     die $! unless defined($n);
  134.     die "short write" if $n != length($requestLine);
  135.     }
  136.  
  137.     my $user_arg = $arg;
  138.  
  139.     # must handle menus in a special way since they are to be
  140.     # converted to HTML.  Undefing $arg ensures that the user does
  141.     # not see the data before we get a change to convert it.
  142.     $arg = undef if $gophertype eq '1' || $gophertype eq '7';
  143.  
  144.     # collect response
  145.     my $buf = '';
  146.     $response = $self->collect($arg, $response, sub {
  147.     die "read timeout" if $timeout && !$sel->can_read($timeout);
  148.         my $n = sysread($socket, $buf, $size);
  149.     die $! unless defined($n);
  150.     return \$buf;
  151.       } );
  152.  
  153.     # Convert menu to HTML and return data to user.
  154.     if ($gophertype eq '1' || $gophertype eq '7') {
  155.     my $content = menu2html($response->content);
  156.     if (defined $user_arg) {
  157.         $response = $self->collect_once($user_arg, $response, $content);
  158.     }
  159.     else {
  160.         $response->content($content);
  161.     }
  162.     }
  163.  
  164.     $response;
  165. }
  166.  
  167.  
  168. sub gopher2url
  169. {
  170.     my($gophertype, $path, $host, $port) = @_;
  171.  
  172.     my $url;
  173.  
  174.     if ($gophertype eq '8' || $gophertype eq 'T') {
  175.     # telnet session
  176.     $url = $HTTP::URI_CLASS->new($gophertype eq '8' ? 'telnet:':'tn3270:');
  177.     $url->user($path) if defined $path;
  178.     }
  179.     else {
  180.     $path = URI::Escape::uri_escape($path);
  181.     $url = $HTTP::URI_CLASS->new("gopher:/$gophertype$path");
  182.     }
  183.     $url->host($host);
  184.     $url->port($port);
  185.     $url;
  186. }
  187.  
  188. sub menu2html {
  189.     my($menu) = @_;
  190.  
  191.     $menu =~ s/\015//g;  # remove carriage return
  192.     my $tmp = <<"EOT";
  193. <HTML>
  194. <HEAD>
  195.    <TITLE>Gopher menu</TITLE>
  196. </HEAD>
  197. <BODY>
  198. <H1>Gopher menu</H1>
  199. EOT
  200.     for (split("\n", $menu)) {
  201.     last if /^\./;
  202.     my($pretty, $path, $host, $port) = split("\t");
  203.  
  204.     $pretty =~ s/^(.)//;
  205.     my $type = $1;
  206.  
  207.     my $url = gopher2url($type, $path, $host, $port)->as_string;
  208.     $tmp .= qq{<A HREF="$url">$pretty</A><BR>\n};
  209.     }
  210.     $tmp .= "</BODY>\n</HTML>\n";
  211.     $tmp;
  212. }
  213.  
  214. 1;
  215.